home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / font / fntgen.zip / FONTGEN.LSP < prev    next >
Text File  |  1992-01-02  |  8KB  |  236 lines
  1. ;
  2. ;                   FONTGEN.LSP
  3. ;   
  4. ;              AUTOCAD FONT GENERATOR
  5. ;
  6. ;        copyright  1991,1992 - Keith P. Whitaker
  7. ;
  8. ;     
  9. (setvar "cmdecho" 0)
  10. (command "vslide" "fnt1")
  11. (defun c:fontgen ()
  12. ;-- INITIALIZATION --
  13. (setvar "cmdecho" 0)
  14. (setq ans "O")
  15. (princ "\n")
  16. (princ "\n            Font Generator - Version 1.0")
  17. (princ "\n")
  18. ;-- INPUT FILE DATA SECTION --
  19. (setq fn (getstring "\nOutput File Name (no extention): "))
  20. (setq fnn (strcat fn ".shp"))
  21. ;CHECK FOR EXISTING FILE
  22. (setq f (findfile fnn))
  23. (if f (setq ans (getstring "\nFont File Exists! (O)verwrite/(A)ppend/(E)dit/(Q)uit : ")))
  24. (if (= ans "A")(setq f1 (open fnn "a")))
  25. (if (= ans "O")(setq f1 (open fnN "w")))
  26. (if (= ans "E")
  27.    (progn
  28.       (setq ans "A")
  29.       (setq scn (getstring "\nCharacter Number to Replace: "))
  30.       (SETQ F1 (OPEN FNN "r"))
  31.       (setq f2 (open (strcat fn ".tmp") "w"))
  32.       (setq lt (read-line f1))
  33.       (setq count 0)
  34.       (while lt
  35.          (if (= (substr lt 1 1) "*")
  36.             (progn
  37.                (setq tr 3 CN "")
  38.                (setq ct (substr lt 2 1))
  39.                (while (/= "," ct)
  40.                   (setq cn (strcat cn ct))
  41.                   (setq ct (substr lt tr 1))
  42.                   (setq tr (+ 1 tr))
  43.                )
  44.                (if (= cn scn)
  45.                   (progn
  46.                      (setq lt (read-line f1)
  47.                            count (- count 1)
  48.                      )
  49.                      (while (/= (substr lt (strlen lt) 1) "0")
  50.                         (setq lt (read-line f1))
  51.                      )
  52.                   )
  53.                   (write-line lt f2)
  54.                )
  55.             )
  56.             (write-line lt f2)
  57.          )
  58.          (setq count (+ count 1))
  59.          (setq lt (read-line f1))
  60.       )
  61.       (close f1)
  62.       (close f2)
  63.       (setq f1 (open (strcat fn ".tmp") "r"))
  64.       (setq f2 (open fnn "w"))
  65.       (repeat COUNT
  66.          (write-line (READ-LINE F1) F2)
  67.       )
  68.       (close f1)
  69.       (setq f1 F2)
  70.    )
  71. )
  72. (if (= ans "Q")()
  73. (progn
  74. ;
  75. ;-- append section
  76. ;
  77. (if (= ans "A")()
  78. ;--overwrite or new --- 
  79.    (progn
  80.       (princ (strcat "*0,4," fn) f1)     ;font file header
  81.       (princ "\n100,50,2,0" f1)         
  82.       (princ "\n*10,5,cr" f1)            ;carrage return
  83.       (princ "\n2,8,0,-120,0" f1)
  84.       (princ "\n*32,5,sp" f1)            ;space
  85.       (princ "\n2,8,75,0,0\n" f1)
  86.    )
  87. )
  88. ;-- INPUT CHARACTERS --
  89. (prompt "\nSelect first letter: ")
  90. (setq lset (ssget))
  91. (while lset
  92.    (setq ip2 (getpoint "\nInsertion Point: "))
  93.    (SETQ EP (GETPOINT "\nEnding Point: "))
  94.    (setq n2$ (STRCASE (getstring "\nName of Letter: ") T))
  95.    (IF CN$ (SETQ OCN$ CN$)(SETQ OCN$ "32"))
  96.    (SETQ OCN$ (RTOS (+ (READ OCN$) 1) 2 0))
  97.    (SETQ CN$ (GETSTRING (STRCAT "\nCharacter Number <" OCN$ ">: ")))
  98.    (IF (= CN$ "")(SETQ CN$ OCN$))
  99.    (setq l1 "2")
  100.    (SETQ OP1 IP2)
  101.    (setq r 0 nb 2)
  102.    (while (< r (sslength lset))
  103.       (setq en1 (entget (ssname lset r)))
  104. ;
  105. ;   ------ polyline segments ---
  106. ;
  107.       (if (= (cdr(assoc 0 en1)) "POLYLINE")
  108.           (progn
  109.              (setq lp2 nil)
  110.              (setq pen2 (entnext (ssname lset r)))
  111.              (setq pent2 (entget pen2))             
  112.              (while (= (cdr(assoc 0 pent2)) "VERTEX")
  113.                 (if lp2 
  114.                    (progn
  115.                       (setq cp1 (cdr(assoc 10 pent2))
  116.                             blg (* 127 (cdr(assoc 42 pent2)))
  117.                             dx1 (- (car cp1) (car lP2))
  118.                             dy1 (- (cadr cp1) (cadr lP2))
  119.                       )
  120.                       (if (or (> dx1 127)(> dy1 127))(prompt "Line Length or Displacement Exceeds 127 units... Skipping Invalid Entry...")
  121.                           (setq l1 (strcat l1 ",1,0C," (rtos dx1 2 0)","(rtos dy1 2 0)","(rtos blg 2 0)",2")
  122.                                 nb (+ nb 6))
  123.                       )
  124.                    )
  125.                    (setq cp1 (cdr(assoc 10 pent2))
  126.                          dx1 (- (car cp1) (car op1))
  127.                          dy1 (- (cadr cp1) (cadr op1))
  128.                          l1 (strcat l1 ",8," (rtos dx1 2 0)","(rtos dy1 2 0))
  129.                          nb (+ nb 3)
  130.                    )     
  131.                 )
  132.                 (setq lp2 cp1)
  133.                 (setq pen2 (entnext pen2))
  134.                 (setq pent2 (entget pen2))
  135.              )
  136.              (SETQ OP1 lP2)
  137.           )
  138.        )
  139. ;
  140. ;   ----- arc segments -----
  141. ;
  142.       (if (= (cdr(assoc 0 en1)) "ARC")
  143.           (progn
  144.              (setq cp1 (cdr(assoc 10 en1))
  145.                    rd (cdr(assoc 40 en1))
  146.                    a1 (cdr(assoc 50 en1))
  147.                    a2 (cdr(assoc 51 en1))
  148.                    p1 (polar cp1 a1 rd)
  149.                    p2 (polar cp1 a2 rd)
  150.                    dx1 (- (car p1) (car OP1))
  151.                    dy1 (- (cadr p1) (cadr OP1))
  152.                    dx2 (- (car p2) (car p1))
  153.                    dy2 (- (cadr p2) (cadr p1))
  154.                    blg (* (1- (abs(car(polar (list 0 0) (abs (/ (- a2 a1) 2)) 1)))) -127)
  155.             )
  156.             (if (or (> dx1 127)(> dy1 127)(> dx2 127)(> dy2 127))(prompt "Line Length or Displacement Exceeds 127 units... Skipping Invalid Entry...")
  157.                 (setq l1 (strcat l1 ",8," (rtos dx1 2 0)","(rtos dy1 2 0) ",1,0C," (rtos dx2 2 0)","(rtos dy2 2 0)","(rtos blg 2 0)",2")
  158.                       nb (+ nb 9))
  159.             )
  160.             (SETQ OP1 P2)
  161.           )
  162.      )
  163. ;
  164. ;   ----- line segments ----
  165. ;
  166.       (if (= (cdr(assoc 0 en1)) "LINE")
  167.           (progn
  168.              (setq p1 (cdr(assoc 10 en1))
  169.                    p2 (cdr(assoc 11 en1))
  170.                    dx1 (- (car p1) (car OP1))
  171.                    dy1 (- (cadr p1) (cadr OP1))
  172.                    dx2 (- (car p2) (car p1))
  173.                    dy2 (- (cadr p2) (cadr p1))
  174.             )
  175.             (if (or (> dx1 127)(> dy1 127)(> dx2 127)(> dy2 127))(prompt "Line Length or Displacement Exceeds 127 units... Skipping Invalid Entry...")
  176.                 (setq l1 (strcat l1 ",8," (rtos dx1 2 0)","(rtos dy1 2 0) ",1,8," (rtos dx2 2 0)","(rtos dy2 2 0)",2")
  177.                       nb (+ nb 8))
  178.             )
  179.             (SETQ OP1 P2)
  180.           )
  181.      )
  182. ;
  183.      (setq r (+ 1 r))
  184.    )
  185.    (SETQ DX (- (CAR EP) (CAR OP1))
  186.          DY (- (CADR EP) (CADR OP1))
  187.    )
  188.    (SETQ L1 (STRCAT L1 ",8," (RTOS DX 2 0) "," (RTOS DY 2 0)))
  189.    (SETQ NB (+ NB 3))
  190.    (setq l1 (strcat l1 ",0"))
  191. ;-- PRINT CHARACTER TO FILE --   
  192.    (princ (strcat "*" cn$ "," (rtos nb 2 0) "," n2$) f1)
  193.    (setq r 1)
  194.    (setq sl (strlen l1))
  195.    (while (< r sl)
  196.       (setq nc (- sl r))
  197.       (if (> nc 30)
  198.           (progn
  199.              (setq nc 30)
  200.              (setq tc (substr l1 (+ r (- nc 1)) 1))
  201.              (while (/= tc ",")
  202.                  (setq nc (- nc 1))
  203.                  (setq tc (substr l1 (+ r (- nc 1)) 1))
  204.              )
  205.           )
  206.           (SETQ NC (+ 1 NC))
  207.       )
  208.       (setq lt (substr l1 r nc))
  209.       (princ (strcat "\n" lt) f1)
  210.       (setq r (+ nc r))
  211.    )
  212.    (PRINC "\n" F1)
  213.    (prompt "\nSelect Next Letter: ")
  214.    (setq lset (ssget))
  215. )
  216. ;-- END FILE --
  217. (close f1)
  218. ;-- script file to create font --
  219. (setq f2 (open "fontgen.scr" "w"))
  220. (princ "END" f2)
  221. (princ "\n7" f2)
  222. (princ (strcat "\n" fn) f2)
  223. (princ "\n" F2)
  224. (princ "\n2" f2)
  225. (princ "\n" f2)
  226. (princ "\n" f2)
  227. (close f2)
  228. ;-- run optional script file --
  229. (prompt "\nShape File Creation Complete........")
  230. (setq ans (getstring "\nCompile Text Font (<Y>/N): "))
  231. (if (= ans "N")()(command "script" "fontgen"))
  232. ))
  233. )
  234. (getstring "\nPress <RET> to continue.....")
  235. (command "redraw")
  236.